home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / interpret.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  9KB  |  393 lines
  1. /*
  2.  * Bytecode Interpreter for Feel
  3.  */
  4.  
  5. #ifdef BCI
  6.  
  7. #include <stdio.h>
  8.  
  9. #include "defs.h"
  10. #include "structs.h"
  11. #include "funcalls.h"
  12. #include "global.h"
  13. #include "ngenerics.h"
  14. #include "modules.h"
  15. #include "bvf.h"
  16. #include "allocate.h"
  17. #include "modboot.h"
  18. #include "error.h"
  19. /* Definition of the bytecodes */  
  20. #define COUNT_BYTES /* ---- I want to see what goes on... */
  21. #include "iset.h"
  22. #include "interpret.h"
  23. #include "bytecodes.h"
  24.  
  25. /* classes */
  26. static LispObject ByteFunction_Class;
  27. static LispObject ByteFunction;
  28.  
  29. /* Boot Modules */
  30. #define MAX_BOOT_MODULES 50
  31.  
  32. BC_GLOBALS()
  33.  
  34. /* Function that returns to 'c' */
  35. static LispObject Cb_generic_lookup;
  36.  
  37. /* Interface from the world */
  38. LispObject compute_and_apply_method();
  39. LispObject call_method();
  40. LispObject module_apply_args();
  41.  
  42. /* The biggie */
  43. LispObject interpret_bytes(LispObject *stacktop, bytecode *start_pc, int context)
  44. {
  45.   /* locals for a few specials */
  46.   LispObject BCtrue=lisptrue;
  47.   LispObject BCnil=nil;
  48.   LispObject BC_globals;
  49.   bytecode *pc;
  50.   LispObject *sp;
  51.   int this_vector;
  52.  
  53.   BC_INITIALISE_GLOBALS();
  54.  
  55.   while (TRUE)
  56.     {
  57.       BC_PRESWITCH();
  58.       switch(*(pc++))
  59.     {
  60.       
  61.       BC_CASE(BC_NOP);
  62.       
  63.       /* Globals, etc */
  64.       BC_CASE(BC_PUSH_GLOBAL);
  65.       BC_CASE(BC_SET_GLOBAL);
  66.       BC_CASE(BC_PUSH_STATIC);
  67.       BC_CASE(BC_PUSH_FIXNUM);
  68.       BC_CASE(BC_SET_STATIC);
  69.  
  70.       BC_CASE(BC_PUSH_SPECIAL);
  71.  
  72.       /* stack refs */
  73.       BC_CASE(BC_PUSH_NTH);
  74.       BC_CASE(BC_SET_NTH);
  75.       
  76.       /* Stack abuse */
  77.       BC_CASE(BC_SLIDE_STACK);
  78.       BC_CASE(BC_SWAP);
  79.       BC_CASE(BC_DROP);
  80.       
  81.       /* env reference */
  82.       BC_CASE(BC_ENV_REF);
  83.       BC_CASE(BC_SET_ENV);
  84.       BC_CASE(BC_POP_ENV);
  85.       BC_CASE(BC_MAKE_ENV);
  86.  
  87.       /* object reference */
  88.       BC_CASE(BC_VREF);
  89.       BC_CASE(BC_SET_VREF);
  90.       BC_CASE(BC_SLOT_REF);
  91.       BC_CASE(BC_SET_SLOT);
  92.       BC_CASE(BC_SET_TYPE);
  93.       
  94.       /* Leaping merrily */
  95.       BC_CASE(BC_BRANCH);
  96.       BC_CASE(BC_BRANCH_NIL);
  97.  
  98.       /* Calling things */
  99.       BC_CASE(BC_APPLY_ANY);
  100.       BC_CASE(BC_APPLY_BVF);
  101.       BC_CASE(BC_APPLY_METHODS);
  102.  
  103.       BC_CASE(BC_PUSH_LABEL);
  104.       
  105.       /* and return */
  106.       BC_CASE(BC_RETURN);
  107.       /* real return */
  108.       BC_CASE(BC_EXIT);
  109.  
  110.       /* allocation */    
  111.       BC_CASE(BC_CONS);
  112.       BC_CASE(BC_ALLOC_CLOSURE);
  113.  
  114.       /* Tests */
  115.       BC_CASE(BC_NULLP);
  116.       BC_CASE(BC_EQP);
  117.       
  118.       BC_CASE(BC_CONTEXT); 
  119.       
  120.       BC_NOINSTRUCT(*(pc-1));
  121.     }
  122.       Cb_generic_lookup=BCnil;
  123.     }
  124.   /* not ever */
  125.   return nil; 
  126. }
  127.  
  128.  
  129. /* Returns a closure which will execute from 0 */
  130. /* It is vital that the vector is not GC'd */
  131. EUFUN_3(Fn_add_codevector,bytes,len, posn)
  132. {
  133.   LispObject new_closure;
  134.   LispObject ptr;
  135.   int i,lim=intval(len);
  136.   bytecode *space;
  137.  
  138.   space=(bytecode *)allocate_space(stacktop,lim);
  139.   ptr=bytes;
  140.  
  141.   for (i=0; i<lim ; i++)
  142.     {
  143.       if (!is_fixnum(CAR(ptr)))
  144.     CallError(stacktop,"add codevector: bad byte",CAR(ptr),NONCONTINUABLE);
  145.       
  146.       if (intval(CAR(ptr))>255)
  147.     CallError(stacktop,"add codevector: bad byte number",CAR(ptr),NONCONTINUABLE);
  148.  
  149.       space[i]=(bytecode)intval(CAR(ptr));
  150.       ptr=CDR(ptr);
  151.     }
  152.  
  153.   new_closure=allocate_instance(stacktop,ByteFunction);
  154.   lval_typeof(new_closure)=TYPE_B_FUNCTION;
  155.  
  156.   bytefunction_offset(new_closure)=allocate_integer(stacktop,0);
  157.   bytefunction_nargs(new_closure)=allocate_integer(stacktop,0);
  158.   bytefunction_env(new_closure)=nil;
  159.   bytefunction_codenum(new_closure)=posn;
  160.   bytevectors[intval(posn)]=space;
  161.   return new_closure;
  162. }
  163. EUFUN_CLOSE
  164.  
  165. #define BUFSIZE 1024
  166. EUFUN_1(Fn_load_bytecodes,name)
  167. {
  168.   char buf[BUFSIZE];
  169.   FILE *file;
  170.   bytecode *code;
  171.   int nslots,nbytes,i;
  172.   LispObject slotvector,*slots;
  173.   
  174.   sprintf(buf,"%s.ebc",stringof(name));
  175.   file=fopen(buf,"r");
  176.  
  177.   if (file==NULL)
  178.     CallError(stacktop,"Could not open file\n",name,NONCONTINUABLE);
  179.  
  180.   fgets(buf,BUFSIZE,file);
  181.   
  182.   if (strcmp(buf,"ASCIIBYTES\n")==0)
  183.     {
  184.       fgets(buf,BUFSIZE,file);
  185.       nslots=atoi(buf);
  186.       fgets(buf,BUFSIZE,file);
  187.       nbytes=atoi(buf);
  188.  
  189.       code=(bytecode *) allocate_space(stacktop,nbytes);      
  190.       bytevectors[SYSTEM_GLOBAL_VALUE(static_count)]=code;
  191.       slotvector=allocate_static_vector(stacktop,sizeof(LispObject)*nslots);
  192.       statics[SYSTEM_GLOBAL_VALUE(static_count)]=slotvector;
  193.       slots= &(vref(slotvector,0));
  194.       fprintf(stderr,"code: %x[%d] slots: %x[%d]\n",code,nbytes,slots,nslots);
  195.       STACK_TMP(slotvector);
  196.       
  197.       for (i=0 ; i<nbytes ; i++)
  198.     {    
  199.       if (fgets(buf,BUFSIZE,file)==NULL)
  200.         perror("fgets");
  201.  
  202.       code[i]=(bytecode) (atoi(buf));
  203.     }
  204.       fclose(file);
  205.     }
  206.   else
  207.     {    
  208.       fprintf(stderr,"%s\n",buf);
  209.       CallError(stacktop,"Unknown format: %s\n",nil,NONCONTINUABLE);
  210.     }
  211.   
  212.   
  213.   /* Load the statics --- should be done in lisp but what the hell... */
  214.  
  215.   sprintf(buf,"%s.est",stringof(name));
  216.   file=fopen(buf,"r");
  217.   if (file==NULL)
  218.     CallError(stacktop,"load-bytecodes: no file",nil,NONCONTINUABLE);
  219.   else
  220.     {
  221.       extern LispObject Fn_Lex_Yacc_reader(LispObject*,FILE *);
  222.       LispObject new;
  223.  
  224.       new=Fn_Lex_Yacc_reader(stacktop,file);
  225.       nslots=intval(new);
  226.       for (i=0; i<nslots ; i++)
  227.     {
  228.       new=Fn_Lex_Yacc_reader(stacktop,file);
  229.       vref(statics[SYSTEM_GLOBAL_VALUE(static_count)],i)=new;
  230.     }
  231.       fclose(file);
  232.     }
  233.   /* Allocate a new closure and interpret it. */
  234.   {
  235.     LispObject apply_nary_bytefunction(LispObject *, int, LispObject);
  236.     LispObject new_closure;
  237.     new_closure=allocate_instance(stacktop,ByteFunction);
  238.     lval_typeof(new_closure)=TYPE_B_FUNCTION;
  239.  
  240.     bytefunction_offset(new_closure)=allocate_integer(stacktop,0);
  241.     bytefunction_nargs(new_closure)=allocate_integer(stacktop,0);
  242.     bytefunction_env(new_closure)=nil;
  243.     bytefunction_codenum(new_closure)=allocate_integer(stacktop,SYSTEM_GLOBAL_VALUE(static_count));
  244.     SYSTEM_GLOBAL_VALUE(static_count)++;
  245.     return(apply_nary_bytefunction(stacktop,0,new_closure));
  246.   }
  247. }
  248. EUFUN_CLOSE
  249.  
  250.  
  251. EUFUN_2(Fn_set_module_statics,module,n)
  252. {
  253.   int i;
  254.   
  255.   i=intval(n);
  256.   module->C_MODULE.values=statics[i];
  257.  
  258.   return nil;
  259. }
  260. EUFUN_CLOSE
  261.  
  262. LispObject apply_nary_bytefunction(LispObject *stackbase, int nargs, LispObject fn)
  263. {
  264.   bytecode *start;
  265.   int this_vector; /* to make reify do the business */
  266.   LispObject rfn;
  267.   int i;
  268.   
  269.   if (is_cons(fn))
  270.     rfn=method_function(CAR(fn));
  271.   else 
  272.     rfn=fn;
  273.   /* move the arguments up a little --- top first */
  274.   
  275.   for (i=nargs-1; i>=0 ; i--)
  276.     *(stackbase+i+2)= *(stackbase+i);
  277.  
  278.   /* Place the exit function in the return address */    
  279.   this_vector=0;
  280.   start=exit_bytes;
  281.   *(stackbase+1)=REIFY_PC(start);
  282.  
  283.   /* Work out where to start (also updates this_vector)*/
  284.   start=BF2PC(rfn);  
  285.   /* hack fn slot */
  286.   *stackbase=fn;
  287.   *(stackbase+nargs+2)=bytefunction_env(rfn);
  288.  
  289.   return(interpret_bytes(stackbase+nargs+3,start,this_vector));
  290. }
  291.  
  292. EUFUN_0(Fn_print_counts)
  293. {
  294.   PRINT_COUNTS;
  295.  
  296.   return nil;
  297. }
  298. EUFUN_CLOSE
  299.  
  300. void add_boot_module(LispObject mod)
  301. {
  302.   boot_modules[boot_module_count]=mod;
  303.   
  304.   if (static_vectors==NULL)
  305.     {
  306.       static_vectors=allocate_static_vector(NULL,MAX_MODS); /* NULL is a hack */
  307.       statics= &(vref(static_vectors,0));
  308.       add_root(&static_vectors);
  309.     }
  310.  
  311.   statics[boot_module_count]=mod->C_MODULE.values;
  312.   boot_module_count++;
  313. }
  314.  
  315. EUFUN_0(Fn_boot_module_list)
  316. {
  317.   LispObject lst,end;
  318.   int i;
  319.   
  320.   lst=EUCALL_2(Fn_cons,nil,nil);
  321.   end=lst; /* not gc safe */
  322.   for (i=1; i<boot_module_count; i++)
  323.     { 
  324.       LispObject tmp;
  325.  
  326.       tmp=EUCALL_2(Fn_cons,boot_modules[i],nil);
  327.       CDR(end)=tmp;
  328.       end=tmp;
  329.     }
  330.   return(lst);
  331. }
  332. EUFUN_CLOSE
  333.  
  334. EUFUN_2(Fn_set_global,n,val)
  335. {
  336.   GLOBAL_REF(intval(n))=val;
  337.  
  338.   return val;
  339. }
  340. EUFUN_CLOSE
  341.  
  342. #define BCI_ENTRIES 8
  343. #define FIRST_USER_CODE 32
  344. MODULE Module_bci;
  345. LispObject Module_bci_values[BCI_ENTRIES];
  346.  
  347. void initialise_bci(LispObject *stacktop)
  348. {
  349.   int i;
  350.   
  351.   fprintf(stderr,"Bytecodes compiled on: %s\n", MAKE_DATE);
  352.   
  353.   SYSTEM_INITIALISE_GLOBAL(int,static_count,FIRST_USER_CODE);
  354.   global_vector=allocate_vector(stacktop,N_GLOBALS);
  355.  
  356.   add_root(&global_vector);
  357.   ByteFunction_Class = (LispObject) allocate_class(stacktop,Standard_Class);  
  358.   add_root(&ByteFunction_Class);
  359.  
  360.   bytevectors=(bytecode **)allocate_space(stacktop,MAX_MODS*sizeof(bytecode *));
  361.  
  362.   make_class(stacktop,ByteFunction_Class,
  363.          "bytefunction-class",
  364.          Standard_Class,
  365.          Funcallable_Object_Class,
  366.          0);
  367.  
  368.   ByteFunction = (LispObject) allocate_class(stacktop,ByteFunction_Class);
  369.   add_root(&ByteFunction);
  370.  
  371.   make_class(stacktop,ByteFunction,
  372.          "bytefunction",
  373.          ByteFunction_Class,
  374.          Function, N_SLOTS_IN_BYTEFUNCTION);
  375.  
  376.  
  377.   open_module(stacktop,
  378.           &Module_bci,Module_bci_values,"bci",BCI_ENTRIES);
  379.   
  380.   (void) make_module_entry(stacktop,"bytefunction-class",ByteFunction_Class);
  381.   (void) make_module_entry(stacktop,"bytefunction",ByteFunction);
  382.   (void) make_module_function(stacktop,"add-code-vector",Fn_add_codevector,3);
  383.   (void) make_module_function(stacktop,"load-bytecodes",Fn_load_bytecodes,1);
  384.   (void) make_module_function(stacktop,"set-module-statics",Fn_set_module_statics,2);
  385.   (void) make_module_function(stacktop,"boot-module-list",Fn_boot_module_list,0);
  386.   (void) make_module_function(stacktop,"byte-counts",Fn_print_counts,0);
  387.   (void) make_module_function(stacktop,"set-bc-global",Fn_set_global,2);
  388.   close_module();
  389.  
  390.   bytevectors[0]=exit_bytes;
  391. }
  392. #endif /* BCI */
  393.